perm filename GEOMED.SAI[GEO,BGB]3 blob
sn#013392 filedate 1972-11-20 generic text, type T, neo UTF8
00010 ENTRY DUMMY;
00100 BEGIN "GEOMED - A GEOMETRIC EDITOR - AUGUST 1972."
00200
00300 REQUIRE "ABBREV" SOURCE_FILE;
00400 REQUIRE "SAITRG" SOURCE_FILE;
00500 REQUIRE "GEOMES" SOURCE_FILE;
00700
00800 α DEFINITIONS;
00900
01000 DEFINE mm = "3.2808@-3";
01100 DEFINE PPIOT="'702000000000";
01200 DEFINE THRICE="FOR I←1 STEP 1 UNTIL 3 DO";
01300 DEFINE PUSH= "PADPDL[PDLPTR←PDLPTR+1]";
01400 DEFINE POP = "PADPDL[1+(PDLPTR←PDLPTR-1)]";
01500 DEFINE TOP = "PADPDL[PDLPTR]";
01600 DEFINE ARG1= "PADPDL[PDLPTR-1]";
01700 DEFINE ARG2= "PADPDL[PDLPTR-2]";
01800
01900 α AD HOC, BOOTSTRAP, PROTO-TYPE WORLD DIRECTORY;
02000
02100 EXTERNAL INTEGER WPTR;
02200 EXTERNAL STRING WORLDNAME;
02300 EXTERNAL STRING ARRAY NAME[1:50];
02400 EXTERNAL INTEGER ARRAY ENTITY[1:50];
02500 EXTERNAL INTEGER ARRAY FILE[1:50];
02600 EXTERNAL INTEGER ARRAY DSKBLK[1:50];
02700 EXTERNAL INTEGER ARRAY PART#[1:50];
02800 EXTERNAL INTEGER ARRAY COPAR#[1:50];
02900
03000 EXTERNAL STRING SUBR ISTR(ITG Q);
00100 α GEOMED'S CONTEXT;
00200 INTERNAL INTEGER ARRAY PADPDL[0:99];
00300 INTERNAL INTEGER PDLPTR;
00400
00500 α TRANSFORMATION STRENGTHS;
00600 INTERNAL REAL TDEL,DDEL,RDEL;
00700
00800 α THE CURRENT TTY COMMAND STATE;
00900 INTERNAL INTEGER CHR,CTRL,META,LETT,αβ,BRK,EOF,
01000
01100 α EUCLIDEAN TRANSFORMATION SWITCHES;
01200 OP, α CONTROL BITS TRANSF OP;
01300 OPERATION, α DEFAULT TRANSF OP;
01400 FRAME, α TRANSF FRAME OF REFERENCE;
01500 FRMORG, α FRAME ORGIN SWITCH;
01600 AXECNT, α NUMBER OF DILATION/REFLECTION AXES;
01700
01800 α DISPLAY MODE SWITCHES;
01900 D0, α DPYSUB STICKY COMMAND FLAG;
02000 FLAGD, α DATUM DISPLAY MODE;
02100 FLAGV, α VERTEX MARKER MODE;
02200 FLAGRS, α REFRESH SUPRRESS;
02300 FLAGED, α SUPPRES EDITOR STATUS;
02400 FLAGL; α SHOW PNAMES FLAG;
02500 INTERNAL INTEGER VERNX,VERNY;
02600 INTERNAL INTEGER ITERATIONS;
02700
02800 INTERNAL STRING TITLE;
02900 EXTERNAL SUBR PLOT;
03000 EXTERNAL PROCEDURE GEDREF;
03100 EXTERNAL SUBR DPYSUB (ITG X);
03200
03300 α GEOMED'S WINDOWS;
03400 INTEGER LDX,LDY,LDZ; REAL PDX,PDY,FOCAL;
03500 INTEGER CAMERA,SWINDO,OWINDO,IIIDPY,LOC;
03600 ITG SXL,SXH,SYL,SYH,SX,SY,SDX,SDY; REAL SA;
03700 REAL OXL,OXH,OYL,OYH,OX,OY,MAGX,MAGY;
03800 ITG DXL,DXH,DYL,DYH,DCX,DCY,DDX,DDY; REAL DA;
00100 α INPUT COMMAND FILE;
00200 STRING ARRAY ICSTR[0:15];
00300 ITG ARRAY ICCHAN[0:16];
00400 INTEGER ICPTR;
00500
00600 INTERNAL STRING PROCEDURE GETSTR;
00700 BEGIN "GETSTR"
00800 STRING STR,STR1,STR2; LABEL L1,L2;
00900
01000 L1: IF ICPTR≠0 ∧ LENGTH(ICSTR[ICPTR])≠0 THEN
01100 ⊂ STR←ICSTR[ICPTR];ICSTR[ICPTR]←"";RETURN(STR);⊃;
01200
01300 α GET A LINE FROM THE TELETYPE;
01400 IF ICPTR=0 THEN
01500 BEGIN
01600 STR ← INCHWL;
01700 RETURN(STR);
01800 END;
01900
02000 α GET A LINE FROM AN X-COMMAND FILE;
02100 L2: STR ← INPUT(ICCHAN[ICPTR],1);
02200 IF EOF THEN
02300 BEGIN
02400 RELEASE(ICCHAN[ICPTR]);DECREM(ICPTR);
02500 IF ICPTR=0 THEN ⊂ OUTSTR(↓&"*");RETURN(" ");⊃
02600 ELSE GO L1;
02700 END;
02800 α COMMANDS MUST BE PREFIXED WITH A "COMMENT-TAB";
02900 STR1 ← SCAN(STR,2,BRK);
03000 IF BRK≠9 THEN GO L2;
03100 α COMMANDS MAY BE SUFFIXED WITH A "TAB-COMMENT";
03200 STR2 ← SCAN(STR,2,BRK);
03300 IF LENGTH(STR2)≠0 THEN STR←STR2 ELSE GO L2;
03400 RETURN(STR2);
03500 END "GETSTR";
00100 ISUBR GETCHR;
00200 BEGIN "GETCHR"
00300 STRING S;
00400 WHILE ICPTR≠0
00500 ∧ (LENGTH(ICSTR[ICPTR]))=0 DO ⊂ S←GETSTR;
00600 ICSTR[ICPTR]←S;⊃;
00700 IF ICPTR=0 THEN RETURN(INCHRW) ELSE
00800 RETURN(LOP(ICSTR[ICPTR]));
00900 END "GETCHR";
00100 α X-COMMAND - EXECUTE A COMMAND FILE;
00200 SUBR XCOMMAND;
00300 BEGIN "XCOMMAND"
00400 ITG I,FLG; STRING STR;
00500 I ← ICCHAN[ICPTR+1] ← GETCHAN;
00600 IF I<0 THEN
00700 ⊂ OUTSTR(↓&"X-COMMAND RECURSION TOO DEEP."&↓);
00800 DECREM(ICPTR);RETURN;⊃;
00900
01000 OPEN(I,"DSK",0,2,0,2000,BRK,EOF);
01100 IF ICPTR=0 THEN DO ⊂
01200 OUTSTR(9&"FILE.GEO = ");
01300 STR ← GETSTR;
01400 IF LENGTH(STR)=0 THEN ⊂ RELEASE(I);RETURN;⊃;
01500 LOOKUP(I,STR,FLG);
01600 IF FLG THEN LOOKUP(I,STR&".GEO",FLG);
01700 IF ICPTR≠0 ∧ FLG THEN
01800 ⊂ OUTSTR(9&STR&" FILE NOT FOUND."&↓);
01900 RELEASE(I);RETURN;⊃;
02000 ⊃ UNTIL ¬FLG;
02100 INCREM(ICPTR);
02200 END "XCOMMAND";
00100 α EUCLIDEAN TRANSFORMATION COMMAND;
00200 PROCEDURE EUTRAN (INTEGER AX,DIR);
00300 BEGIN "EUTRAN"
00400 INTEGER Q,R,B,B0,I,OPAXCNT;REAL DELTA;
00500 XSUBR EUCLID(ITG Q,OPAXCNT;REAL DELTA);
00600
00700 α PICK'EM UP;
00800 IF PDLPTR=0 THEN RETURN;
00900 IF Q=0 THEN Q←MKLOCOR;
01000 B ← BODY(TOP);
01100 IF FRAME=2 THEN B0←SUPART(B);
01200
01300 α INIT THE FRAME OF REFERENCE;
01400 R ← CASE FRAME OF (WORLD,B,B0,CAMERA);
01500 R ← LOCOR(R);
01600 BLIT(Q-3,R-3,12);
01700 IF ¬FRMORG THEN ⊂ I←LOCOR(B);
01800 IF I≠0 THEN BLIT(Q-3,I-3,3); α BODY'S ORIGIN;⊃;
01900
02000 α SETUP A EUCLIDEAN TRANSFORMATION MATRIX IN Q;
02100 OPAXCNT ← (OP*64 + AX*8 + AXECNT);
02200 DELTA ← (CASE OP OF(DIR*TDEL,DIR*RDEL,
02300 (IF DIR<0 THEN DDEL ELSE 1/DDEL),-1));
02400 EUCLID(Q,OPAXCNT,DELTA);
02500 ITERATIONS←1 MAX ITERATIONS;
02600
02700 α CALL THE TRANSFORMATION;
02800 FOR I←1 TO ITERATIONS DO
02900 ⊂ CASE OP OF
03000 ⊂ TRANSLATE(TOP,Q);
03100 ROTATE (TOP,Q);
03200 DILATE (TOP,Q);
03300 ⊂ REFLECT (TOP,Q);IF AXECNT≠2 THEN EVERT(TOP);⊃;⊃;
03400 DPYSUB(D0);⊃;
03500 END "EUTRAN";
00100 SUBR INITCAM;
00200 BEGIN "INITCAM"
00300 DACR(PDX,CAMERA+#PDX);
00400 DACR(PDY,CAMERA+#PDY);
00500 DACR(FOCAL,CAMERA+#FOCAL);
00600
00700 DAC(LDX,CAMERA+#LDX);
00800 DAC(LDY,CAMERA+#LDY);
00900 DAC(LDZ,CAMERA+#LDZ);
01000
01100 DACR(-FOCAL*LDX/PDX,CAMERA+#XSCALE);
01200 DACR(-FOCAL*LDY/PDY,CAMERA+#YSCALE);
01300 DACR( FOCAL*LDZ ,CAMERA+#ZSCALE);
01400 END "INITCAM";
01500
01600 INTERNAL SUBR INITIA;
01700 BEGIN "INIT"
01800 LABEL L;
01900 EXTERNAL STRING WORLDNAME;
02000 EXTERNAL INTEGER BGND;
02100 WORLDNAME ← "TMP";
02200
02300 α AD HOC WORLD INITIALIZATION;
02400 WORLD ← GETBLK(5+10) + 4;
02500 RINGO(WORLD,#ALBODY);
02600 RINGO(WORLD,#CAMERA);
02700 LOC ← MKLOCOR; DAP(LOC,WORLD-2);
02800 DAP(-WORLD,WORLD-3);
02900 DIP(-WORLD,WORLD-3);
03000
03100 α MAKE BACKGROUND PSEUDO-FACE;
03200 BGND ← GETBLK(10)+3; DACR(1,BGND-1);
03300
03400 α AD HOC CAMERA RING INITIALIZATION;
03500 CAMERA← GETBLK(5+10) + 4;
03600 LOC ← MKLOCOR; DACR(16.0,LOC-1);
03700 RINGIN(CAMERA,WORLD,#CAMERA);
03800 RINGO(CAMERA,#QRING);
03900 RINGO(CAMERA,#LOCOR);
04000 DAP(LOC,CAMERA-2);
04100 RINGIN(LOC,CAMERA,#LOCOR);
04200
04300 PDX←12.7*mm*288/(2*345);
04400 PDY←9.5*mm*216/(2*256);
04500 FOCAL←12.5*mm;
04600
04700 LDX ← 144;
04800 LDY ← 108;
04900 LDZ ← 100000;
05000 INITCAM;
00100 α SOURCE WINDOW;
00200 SWINDO← GETBLK(2+10) + 1; RINGIN(SWINDO,CAMERA,#QRING);
00300 SXL←-LDX; SXH←+LDX; SX←0; SDX←LDX;
00400 SYL←-LDY; SYH←+LDY; SY←0; SDY←LDY; SA←SDX/SDY;
00500 DAC(SXL,SWINDO+#XL); DAC(SXH,SWINDO+#XH);
00600 DAC(SYL,SWINDO+#YL); DAC(SYH,SWINDO+#YH);
00700 DAC(SX, SWINDO+#OX); DAC(SY, SWINDO+#OY);
00800 DAC(SDX,SWINDO+#DX); DAC(SDY,SWINDO+#DY);
00900
01000 α III DISPLAY WINDOW FRAME;
01100 IIIDPY← GETBLK(4+10) + 3;
01200 DDX←DDY←511; DA←1;
01300 DXL←DCX-DDX; DXH←DCX+DDX;
01400 DYL←DCY-DDY; DYH←DCY+DDY;
01500 DAC(DDX,IIIDPY+#DX);DAC(DDY,IIIDPY+#DY);
01600 DACR(-DDX,IIIDPY+#XL);DACR(DDX,IIIDPY+#XH);
01700 DACR(-DDY,IIIDPY+#YL);DACR(DDY,IIIDPY+#YH);
01800
01900 α OBJECT WINDOW;
02000 OWINDO← GETBLK(3+10) + 2; DAP(OWINDO,SWINDO);
02100 DAP(IIIDPY,OWINDO);
02200 α CRAM SWINDO INTO DPY FRAME OWINDO;
02300 MAGX←MAGY←(IF SA>DA THEN DDX/SDX ELSE DDY/SDY);
02400 DACR(MAGX,OWINDO+#MAGX);
02500 DACR(MAGY,OWINDO+#MAGY);
02600 α CROP MAGNIFIED SWINDO INTO DPY FRAME OWINDO;
02700 OXL ← (OX-MAGX*SDX)MAX DXL;
02800 OXH ← (OX+MAGX*SDX)MIN DXH;
02900 OYL ← (OY-MAGY*SDY)MAX DYL;
03000 OYH ← (OY+MAGY*SDY)MIN DYH;
03100 DACR(OXL,OWINDO+#XL); DACR(OXH,OWINDO+#XH);
03200 DACR(OYL,OWINDO+#YL); DACR(OYH,OWINDO+#YH);
03300 DACR(OX-SX*MAGX,OWINDO+#SOX);
03400 DACR(OY-SY*MAGY,OWINDO+#SOY);
00100 α INITIALIZE GEOMED CONTEXT;
00200 AXECNT ← 1;
00300 FRAME ← 0;
00400 PDLPTR ← 0;
00500 TDEL ← 1;
00600 RDEL ← π/4;
00700 DDEL ← 0.75;
00800 α SHOW THE INITIAL DISPLAY;
00900 VERNX ← -12; VERNY ← -9;
01000 START_CODE PPIOT 2,-250;PPIOT 3,'3003;⊃;
01100 L: DPYSUB(D0);
01200 GEDREF;
01300 ⊂ INTEGER I;FOR I←1 TO 20 DO OUTSTR(↓);⊃;
01400 OUTCHR("*");
01500 BREAKSET(1,13,"I");
01600 BREAKSET(1,10,"O");
01700 BREAKSET(1,"","N");
01800 BREAKSET(2, 9,"I");
01900 END "INIT";
02000
02100
02200 SUBR VERN;
02300 WHILE TRUE DO
02400 BEGIN
02500 INTEGER CHR;
02600 CHR ← GETCHR;
02700 IF CHR="(" THEN DECREM(VERNY) ELSE
02800 IF CHR=")" THEN INCREM(VERNY) ELSE
02900 IF CHR=";" THEN DECREM(VERNX) ELSE
03000 IF CHR=":" THEN INCREM(VERNX) ELSE ⊂ OUTSTR(↓&"*");DONE ⊃;
03100 GEDREF;
03200 END;
00100 α STRENGTH MODIFYING COMMANDS;
00200
00300 SUBR SETDIG (ITG N);CASE OP OF
00400 ⊂ ITERATIONS←ITERATIONS*10 + N;
00500 RDEL←3.1415927/2.0↑(10-N);
00600 DDEL←IF N THEN N/10 ELSE 1;
00700 TDEL←2.0↑(N-4);⊃;
00800
00900 SUBR HALVE; CASE OP OF
01000 ⊂ TDEL←TDEL/2; RDEL←RDEL/2; DDEL←DDEL/2;;⊃;
01100
01200 SUBR DOUBLE; CASE OP OF
01300 ⊂ TDEL←TDEL*2; RDEL←RDEL*2; DDEL←DDEL*2;;⊃;
01400 α STRENGTH INPUT COMMANDS;
01500
01600 SUBR GET_λ;
01700 BEGIN
01800 INTEGER B;
01900 STRING STR0;
02000 STR0 ← GETSTR;
02100 TDEL ← REALSCAN(STR0,B);
02200 IF B="'" THEN
02300 TDEL←TDEL+REALSCAN(STR0,B)/12 ELSE
02400 IF B="""" THEN TDEL←TDEL/12;
02500 END;
02600
02700 SUBR GET_π;
02800 BEGIN
02900 INTEGER B,C,I,J;
03000 STRING STR0,STR1;
03100 STR0 ← GETSTR;
03200 STR1←STR0;
03300 IF STR1="/" THEN BEGIN I←1;B←"/";C←LOP(STR0) END ELSE
03400 I ← INTSCAN(STR0,B) ;
03500 IF B="." ∨ B="/" ∨ B="," THEN J ← INTSCAN(STR0,C) ELSE
03600 BEGIN J←0;B←"," END;
03700 IF B="/" THEN
03800 ⊂ IF J=0 THEN J←1;RDEL←3.1415927*I/J ⊃ ELSE
03900 IF B="." THEN RDEL←REALSCAN(STR1,C) ELSE
04000 IF B="," THEN
04100 RDEL←1.74532925@-2*(I+J/(10↑LENGTH(CVS(J))))ELSE
04200 RDEL←1.74532925@-2;
04300 END;
00100 REAL QTMP; INTEGER IQTMP,BRKCHR;
00200 STRING STR;
00300 SUBR GETFOCAL;
00400 BEGIN
00500 SETFORMAT(0,4);
00600 OUTSTR(↓&9&"FOCAL = "&CVG(FOCAL/MM)&"MM"&9&"FOCAL ← ");
00700 STR ← GETSTR;
00800 QTMP ← REALSCAN(STR,BRKCHR);
00900 IF QTMP>0 THEN FOCAL←QTMP*MM;INITCAM;
01000 DPYSUB(D0);
01100 END;
01200
01300 SUBR GETLDX;
01400 BEGIN
01500 OUTSTR(↓&9&"LDX = "&CVS(LDX)&" PIXELS"&9&"LDX ← ");
01600 STR ← GETSTR;
01700 IQTMP ← INTSCAN(STR,BRKCHR);
01800 IF IQTMP>0 THEN LDX←IQTMP;
01900 DPYSUB(D0);
02000 END;
02100
02200 SUBR GETLDY;
02300 BEGIN
02400 OUTSTR(↓&9&"LDY = "&CVS(LDY)&" PIXELS"&9&"LDY ← ");
02500 STR ← GETSTR;
02600 IQTMP ← INTSCAN(STR,BRKCHR);
02700 IF IQTMP>0 THEN LDY←IQTMP;
02800 DPYSUB(D0);
02900 END;
03000
03100 SUBR GETPDX;
03200 BEGIN
03300 SETFORMAT(0,4);
03400 OUTSTR(↓&9&"PDX = "&CVG(PDX/MM)&" MM"&9&"PDX ← ");
03500 STR ← GETSTR;
03600 QTMP ← REALSCAN(STR,BRKCHR);
03700 IF QTMP>0 THEN PDX←QTMP*MM;
03800 DPYSUB(D0);
03900 END;
04000
04100 SUBR GETPDY;
04200 BEGIN
04300 SETFORMAT(0,4);
04400 OUTSTR(↓&9&"PDY = "&CVG(PDY/MM)&" MM"&9&"PDY ← ");
04500 STR ← GETSTR;
04600 QTMP ← REALSCAN(STR,BRKCHR);
04700 IF QTMP>0 THEN PDY←QTMP*MM;
04800 DPYSUB(D0);
04900 END;
00100 α FACE KOLORING AND FOTOMETRY:
00200 SUBR KOLORING:
00300 BEGIN "KOLOR"
00400 INTEGER ARRAY ITEMVAR IFACE,F:
00500 SET FACES:
00600 INTEGER CHR,R,B,G,A,S,L,WORD,PTR,Q,V:
00700 STRING STR:
00800 IF PDLPTR=0 THEN RETURN:
00900 IFACE ← TOP:
01000 FACES ← PHI:
01100 IF BTYPE(IFACE) THEN ⊂ F←PBF(IFACE):
01200 WHILE FTYPE(F) DO ⊂ PUT F IN FACES:F←PBF(F) ⊃ ⊃ ELSE
01300 IF FTYPE(IFACE) THEN PUT IFACE IN FACES ELSE RETURN:
01400 IFACE ← COP(FACES): WORD←∂(IFACE)[5]:
01500 PTR ← POINT(6,WORD,-1):
01600 R ← ILDB(PTR):G ← ILDB(PTR):B ← ILDB(PTR):
01700 A ← ILDB(PTR):S ← ILDB(PTR):L ← ILDB(PTR):
01800 OUTSTR(↓&9&"KOLORING ← "):
01900 STR ← GETSTR & ".":
02000 V ← Q ← 0:
02100 WHILE LENGTH(STR)≠0 DO
02200 BEGIN
02300 CHR ← LOP(STR):
02400 IF "0"≤CHR ∧ CHR≤"9" THEN V←V*10 + (CHR LAND '17) ELSE
02500 BEGIN
02600 IF Q="R" THEN ⊂ R←63*(V MIN 100)%100:V←0: ⊃ ELSE
02700 IF Q="G" THEN ⊂ G←63*(V MIN 100)%100:V←0: ⊃ ELSE
02800 IF Q="B" THEN ⊂ B←63*(V MIN 100)%100:V←0: ⊃ ELSE
02900 IF Q="A" THEN ⊂ A←63*(V MIN 100)%100:V←0: ⊃ ELSE
03000 IF Q="S" THEN ⊂ S←63*(V MIN 100)%100:V←0: ⊃ ELSE
03100 IF Q="L" THEN ⊂ L←63*(V MIN 100)%100:V←0: ⊃ :
03200 Q ← CHR:
03300 END:
03400 END:
03500 PTR ← POINT(6,WORD,-1):
03600 IDPB(R,PTR):IDPB(G,PTR):IDPB(B,PTR):
03700 IDPB(A,PTR):IDPB(S,PTR):IDPB(L,PTR):
03800 ∀ IFACE|IFACEεFACES DO ∂(IFACE)[5] ← WORD:
03900 GEDREF:
04000 END "KOLOR";
00100 SUBR LINKER;
00200 BEGIN "LINKER"
00300 ITG F;
00400
00500 α MOVE THE PED OF A FACE;
00600 IF αβ=3 ∧ PDLPTR≥1 ∧ FTYPE(TOP) THEN
00700 IF CHR="." THEN
00800 ⊂ F←TOP;PED.(ECCW(PED(F),F),F);RETURN;⊃ ELSE
00900 IF CHR="," THEN
01000 ⊂ F←TOP;PED.(ECW(PED(F),F),F);RETURN;⊃;
01100
01200 IF PDLPTR<2 THEN RETURN;
01300 α ARE THERE VALID ARGUMENTS IN THE STACK;
01400 IF ETYPE(TOP) ∧ (FTYPE(ARG1) ∨ VTYPE(ARG1)) THEN
01500 BEGIN
01600
01700 IF CHR="+" THEN
01800 ⊂ ARG1 ← OTHER(TOP,ARG1);RETURN ⊃;
01900
02000 IF ¬CTRL THEN ⊂
02100 IF CHR="," THEN TOP←ECW(TOP,ARG1) ELSE
02200 IF CHR="." THEN TOP←ECCW(TOP,ARG1);RETURN ⊃;
02300
02400 IF FTYPE(ARG1) THEN ⊂
02500 IF CHR="," THEN ARG1←VCW(TOP,ARG1) ELSE
02600 IF CHR="." THEN ARG1←VCCW(TOP,ARG1);RETURN ⊃;
02700
02800 IF CHR="," THEN ARG1←FCW(TOP,ARG1) ELSE
02900 IF CHR="." THEN ARG1←FCCW(TOP,ARG1);RETURN;
03000 END ELSE
03100 IF (FTYPE(ARG1)∧VTYPE(TOP)) ∨ (FTYPE(TOP)∧VTYPE(ARG1)) THEN
03200 IF CHR="." THEN TOP←ECCW(TOP,ARG1) ELSE
03300 IF CHR="," THEN TOP←ECW(TOP,ARG1);
03400
03500 END "LINKER";
00100 α CREATE COMMANDS;
00200
00300 SUBR VBODY;
00400 BEGIN
00500 INTEGER B,X;
00600 IF CTRL THEN PUSH ← B ← MKB(WORLD) ELSE ⊂ B ← MKBFV;
00700 PUSH ← B;
00800 PUSH ← CDR(B+1);
00900 PUSH ← CDR(B+3);⊃;
01000 RINGIN(B,WORLD,#ALBODY);
01100 INCREM(WPTR); ENTITY[WPTR]←PART#[WPTR]←COPAR#[WPTR]←B;
01200 PNAME.(WPTR,B);X←SERIAL(B);NAME[WPTR]←"B"&CVS(X);
01300 LOCOR.(MKLOCOR,B);
01400 END;
01500
01600 SUBR SWIRE;
01700 IF PDLPTR≥1 ∧ LINKED(ARG1,TOP) THEN
01800 ⊂ TOP←MKEV(ARG1,TOP);DPYSUB(D0);⊃;
01900
02000 INTERNAL PROCEDURE KILL;
02100 BEGIN "KILL"
02200 XISUBR KILLF (ITG F);
02300 ITG Q;
02400
02500 IF PDLPTR=0 THEN RETURN;
02600 Q ← TOP;
02700 IF VTYPE(Q) THEN
02800 IF PED(Q)=(ECCW(ECCW(PED(Q),Q),Q))
02900 THEN TOP←KLEV(Q)
03000 ELSE TOP←KLFE(KLEV(Q)) ELSE
03100 IF ETYPE(Q) THEN
03200 IF CTRL THEN TOP←KLVE(Q) ELSE TOP←KLFE(Q) ELSE
03300 IF FTYPE(Q) THEN TOP←KILLF(Q) ELSE
03400 IF BTYPE(Q) THEN ⊂ KLBFEV(Q);DECREM(PDLPTR) ⊃;
03500
03600 DPYSUB(D0);
03700
03800 END "KILL";
03900
00100 INTERNAL PROCEDURE MIDPOI;
00200 BEGIN "MIDPOINT"
00300 REAL D1,D2;
00400 ITG V1,V2,E,VNEW;
00500 IF PDLPTR=0 THEN RETURN;E←TOP;
00600 IF ¬ETYPE(E) THEN RETURN;
00700 D1 ← DDEL; D2←1-D1;
00800 V1 ← PVT(E); V2 ← NVT(E);
00900 VNEW ← ESPLIT(E);
01000 DACR(D1*XWC(V1)+D2*XWC(V2),VNEW-3);
01100 DACR(D1*YWC(V1)+D2*YWC(V2),VNEW-2);
01200 DACR(D1*ZWC(V1)+D2*ZWC(V2),VNEW-1);
01300 TOP←VNEW;
01400 DPYSUB(D0);
01500 END "MIDPOINT";
00100 SUBR MACRO;
00200 IF CTRL THEN
00300 PTOSTR(0,"V:@E*E*E*E*E*E*E*J↑↑>↓>↔!\\://@S)S)S)S)S)S)S)S)G!") ELSE
00400 IF META THEN
00500 PTOSTR(0,"V\:)\E;E(E:J↑/*S--↑/@/:)\!H") ELSE
00600 PTOSTR(0,"V\:)\E;E(E:J↑/*S--↑/@/:)\!");
00700
00800 SUBR NAMER;
00900 BEGIN
01000 STRING S;
01100 IF ¬BTYPE(TOP) THEN RETURN;
01200 S←GETSTR;NAME[PNAME(TOP)]←S;
01300 END;
01400
01500 SUBR RETRIEVE;
01600 BEGIN
01700 STRING STR;
01800 INTEGER I;
01900 STR ← GETSTR;
02000 FOR I←1 TO WPTR DO
02100 IF EQU(STR,NAME[I]) THEN
02200 ⊂ PUSH←ENTITY[I];RETURN;⊃;
02300 END;
00100 PROCEDURE JOINVV;
00200 BEGIN "JOINVV"
00300 ITG V1,V2,U,V;
00400 ITG E0,E1,E2,E,F;
00500 IF PDLPTR<2 THEN RETURN;
00600 α PICKUP THE ARGUMENTS;
00700 V1←TOP; V2←F←ARG1;
00800 IF FTYPE(V1)∧FTYPE(V2) THEN
00900 ⊂ U←VCW(PED(V1),V1);V←VCW(PED(V2),V2);
01000 ARG1←GLUEE(V1,U,V2,V);DECREM(PDLPTR);DPYSUB(D0);RETURN;⊃;
01100 IF ¬VTYPE(V1) ∨ (V1=V2) THEN ⊂ OUTSTR("LOSE-1");RETURN;⊃;
01200 IF VTYPE(V2) THEN
01300 BEGIN "VV-CASE" LABEL WINNER;
01400 α GET THE COMMON FACE;
01500 E0 ← E ← PED(V1);
01600 DO BEGIN
01700 F ← FCCW(E,V1);
01800 E2 ← PED(V2);
01900 DO IF F=FCCW(E2,V2) THEN GO WINNER ELSE E2←ECCW(E2,V2)
02000 UNTIL E2=PED(V2);
02100 E ← ECCW(E,V1);
02200 END UNTIL E=E0;
02300 OUTSTR(9&ISTR(V1)&" & "&ISTR(V2)&
02400 "HAVE NO FACE IN COMMON."&↓); RETURN;
02500 WINNER: DECREM(PDLPTR); TOP←MKFE(V1,F,V2); DPYSUB(D0); RETURN;
02600 END "VV-CASE";
02700 E ← PED(F);
02800 V2 ← PVT(E);
02900 IF ¬VTYPE(V2) THEN ⊂ OUTSTR("LOSE-2");RETURN;⊃;
03000 E ← MKFE(V2,F,V1);
03100 TOP←V2;
03200 DPYSUB(D0);
03300 END "JOINVV";
00100 α GEOMED COMMAND SCANNER - A JUMP TABLE;
00200
00300 INTERNAL SUBR GEOMED;
00400 BEGIN "GEOMED"
00500 WHILE TRUE DO
00600 BEGIN "TTYCOM"
00700 BOOLEAN αFLAG,βFLAG;
00800 α WAIT HERE FOR A TELETYPE CHARACTER;
00900 CHR ← GETCHR;
01000 α CONTROL AND META - KEYS,BITS,FLAGS,CHARACTERS AND SWITCHS;
01100 αβ ← (CHR LSH -7) LAND 3;
01200 CTRL ← (CHR LAND '200);
01300 META ← (CHR LAND '400);
01400 CTRL ← CTRL ∨ αFLAG;
01500 META ← META ∨ βFLAG;
01600 αFLAG ← βFLAG ← FALSE;
01700 OP ← (CTRL LAND 1) + (META LAND 2);
01800 OP ← IF OP THEN OP ELSE OPERATION;
01900 CHR ← CHR LAND '177;
02000 LETT ← CHR LAND '37;
02100
02200 DEFINE OK1="IF PDLPTR≥1 THEN";
02300 DEFINE OK1B="IF PDLPTR≥1 ∧ BTYPE(TOP) THEN";
02400 DEFINE OK2="IF PDLPTR≥2 THEN";
02500 DEFINE OK3="IF PDLPTR≥3 THEN";
00100 IF "A"≤CHR ∧ CHR≤"Z" ∨ "a"≤CHR ∧ CHR≤"z" THEN
00200 CASE LETT OF
00300 BEGIN;
00400 "A" IF META THEN AXECNT←CASE AXECNT OF (0,2,3,1) ELSE
00500 OK2 ATTACH(TOP,ARG1);
00600 "B" OK1B ⊂ XSUBR MKCURV(ITG B);MKCURV(TOP);DPYSUB(D0);⊃;
00700 "C" ⊂ XISUBR MKCOPY(ITG B);ITG B; OK1B ⊂ B←MKCOPY(TOP);
00800 RINGIN(B,WORLD,#ALBODY);
00900 INCREM(WPTR); ENTITY[WPTR]←PART#[WPTR]←COPAR#[WPTR]←B;
01000 PNAME.(WPTR,B);
01100 NAME[WPTR]←"B"&CVS(SERIAL(B));LOCOR.(MKLOCOR,B);
01200 PUSH←B;DPYSUB(D0);⊃;⊃;
01300 "D" OK1 IF αβ=0 THEN DETACH(TOP) ELSE
01400 IF αβ=1∧ETYPE(TOP) THEN ⊂ DIP('040000 LOR CAR(TOP),TOP);DPYSUB(0);⊃ ELSE
01500 IF αβ=2 THEN ⊂ XSUBR FVDUAL(ITG X);FVDUAL(TOP);DPYSUB(D0);⊃ ELSE
01600 IF αβ=3∧ETYPE(TOP) THEN ⊂ DIP('737777 LAND CAR(TOP),TOP);DPYSUB(0);⊃;
01700 "E" SWIRE;
01800 "F" IF CTRL THEN GETFOCAL ELSE FRAME ← (FRAME+1)MOD 4;
01900 "G" OK2 ⊂ XISUBR GLUE(ITG F1,F2);
02000 IF CTRL ∧ ¬META THEN ATTACH(TOP,ARG1) ELSE
02100 ⊂ ARG1←GLUE(TOP,ARG1);DECREM(PDLPTR);⊃;OUTSTR(↓&"*");⊃;
02200 "H" ;
02300 "I" ⊂ XISUBR IFILE(ITG I;STRING S);
02400 PUSH←IFILE(WORLD,"");DPYSUB(D0);⊃;
02500 "J" JOINVV;
02600 "K" KILL;
02700 "L" FLAGL←¬FLAGL;
02800 "M" IF CTRL THEN DPYSUB(3) ELSE MIDPOI;
02900 "N" NAMER;
03000 "O" OK1 ⊂ XSUBR OFILE(ITG B);OFILE(TOP);OUTCHR("*"); ⊃;
03100 "P" IF αβ=3 THEN ⊂ XSUBR PLOT; PLOT;⊃ ELSE ⊂ ITG B; B←TOP;
03200 IF PDLPTR≥1 ∧ (BTYPE(B) ∨ B=WORLD) THEN ⊂
03300 B ← ABS(CASE αβ OF(PART(B),COPART(B),SUPART(B)));
03400 IF B≠TOP THEN PUSH←B;⊃;⊃;
03500 "Q" FRMORG ← ¬FRMORG;
03600 "R" IF ¬CTRL THEN RETRIEVE ELSE
03700 ⊂ XSUBR ROTCOM(ITG X);OK1 ROTCOM(TOP);DPYSUB(D0);⊃;
03800 "S" OK1 ⊂ XISUBR SWEEP(ITG F,M,C);
03900 TOP←SWEEP(TOP,META,CTRL);DPYSUB(D0);⊃;
04000 "T" ⊂ OUTSTR(↓&9&"TITLE ← ");TITLE ← GETSTR;DPYSUB(D0);⊃;
04100 "U" ⊂ XSUBR KLTEMP;KLTEMP;⊃;
04200 "V" IF META THEN VERN ELSE VBODY;
04300 "W" ⊂ XSUBR WORLDI;XSUBR WORLDO; IF META THEN ⊂
04400 OUTSTR(↓&WORLDNAME&" WORLD = ");WORLDNAME←GETSTR ⊃ ELSE
04500 IF CTRL THEN WORLDI ELSE WORLDO;⊃;
04600 "X" IF CTRL THEN GETLDX ELSE IF META THEN GETPDX ELSE XCOMMAND;
04700 "Y" IF CTRL THEN GETLDY ELSE IF META THEN GETPDY;
04800 "Z" IF CTRL THEN ⊂ XSUBR RESERIAL(ITG G);
04900 OK1 RESERIAL(TOP);⊃ ELSE
05000 OK1 IF BTYPE(TOP)∧LOCOR(TOP)=0 THEN LOCOR.(MKLOCOR,TOP);
05100 END ELSE
00100 α ASCII 00 TO 37 ;
00200 IF CHR < "A" THEN CASE CHR OF BEGIN
00300 "NULL" ;
00400 "↓" IF META∧PDLPTR≥2 THEN ⊂ ITG I; FOR I←1 TO PDLPTR DO
00500 PADPDL[I-1]←PADPDL[I];TOP←PADPDL[0];⊃ ELSE PUSH←ARG1;
00600 "α" αFLAG ← TRUE;
00700 "β" βFLAG ← TRUE;
00800 "∧" IF PDLPTR≥1 THEN TOP←PVT(TOP);
00900 "¬" IF CTRL THEN ⊂ XISUBR BSUB(ITG B1,B2); IF PDLPTR≥2 THEN
01000 ARG1 ← BSUB(ARG1,TOP);DECREM(PDLPTR);DPYSUB(D0);⊃ ELSE
01100 OK1B ⊂ EVERT(TOP);DPYSUB(1);⊃;
01200 "ε" αFLAG ← βFLAG ← TRUE;
01300 "π" GET_π;
01400 "λ" GET_λ;
01500 "TAB" ;
01600 "LF" ;
01700 "VT" ;
01800 "FF" ;
01900 "CR" ⊂ OUTSTR("*");ITERATIONS←0 ⊃;
02000 "∞" MACRO;
02100 "∂" FLAGD ← ¬FLAGD ;
02200 "⊂" ;
02300 "⊃" ;
02400 "∩" ⊂ XISUBR BIN(ITG B1,B2);
02500 IF PDLPTR≥2 THEN ARG1←BIN(TOP,ARG1);DECREM(PDLPTR);DPYSUB(D0);⊃;
02600 "∪" ⊂ XISUBR BUN(ITG B1,B2);IF PDLPTR≥2 THEN ARG1←BUN(TOP,ARG1);
02700 DECREM(PDLPTR);DPYSUB(D0);⊃;
02800 "∀" ;
02900 "∃" OPERATION←3;
03000 "⊗" OK1 ⊂ XSUBR MKCONVEX(ITG Q);MKCONVEX(TOP);DPYSUB(D0);⊃;
03100 "↔" IF PDLPTR≥2 THEN TOP↔ARG1;
03200 "_" FLAGV ← ¬FLAGV;
03300 "→" IF PDLPTR≥1 THEN TOP←BODY(TOP);
03400 "TILDE" IF PDLPTR≥3 THEN ARG1↔ARG2;
03500 "≠" FLAGRS←¬FLAGRS;
03600 "≤" OK1 IF ETYPE(TOP)∨BTYPE(TOP) THEN TOP←NED(TOP);
03700 "≥" IF PDLPTR≥1 THEN TOP←PED(TOP);
03800 "≡" FLAGED←¬FLAGED;
03900 "∨" IF PDLPTR≥1 ∧ ¬FTYPE(TOP) THEN TOP←NVT(TOP);
00100 α ASCII 40 TO 77;
00200 "SPACE" ;
00300 "!" OPERATION←0;
00400 """" ;
00500 "#" ⊂ INTEGER I; FOR I←1 TO 20 DO OUTSTR(↓)END;
00600 "$" ;
00700 "%" ⊂ STRING STR;STR←GETSTR;DDEL←REALSCAN(STR,0)/100 ⊃;
00800 "&" ;
00900 "'" ;
01000 "(" EUTRAN(1,-1);
01100 ")" EUTRAN(1,1);
01200 "*" EUTRAN(2,1);
01300 "+" LINKER;
01400 "," IF αβ=2 THEN IF PDLPTR≥3 THEN TOP↔ARG2 ELSE ELSE LINKER;
01500 "-" EUTRAN(2,-1);
01600 "." IF αβ=2 THEN PUSH ← CAMERA ELSE LINKER;
01700 "/" HALVE;
01800 "0" SETDIG(0);
01900 "1" SETDIG(1);
02000 "2" SETDIG(2);
02100 "3" SETDIG(3);
02200 "4" SETDIG(4);
02300 "5" SETDIG(5);
02400 "6" SETDIG(6);
02500 "7" SETDIG(7);
02600 "8" SETDIG(8);
02700 "9" SETDIG(9);
02800 ":" EUTRAN(0,1);
02900 ";" EUTRAN(0,-1);
03000 "<" IF PDLPTR≥1 THEN TOP←NFACE(TOP);
03100 "=" OPERATION←2;
03200 ">" IF PDLPTR≥1 THEN TOP←PFACE(TOP);
03300 "?" ;
03400 "@" OPERATION←1;
03500 END ELSE
00100 IF CHR<"a" THEN CASE CHR-'133 OF
00200 BEGIN
00300 "[" ;
00400 "\" DOUBLE;
00500 "]" ;
00600 "↑" IF META ∧ PDLPTR≥2 THEN ⊂ ITG I;PADPDL[0]←TOP;
00700 FOR I←PDLPTR STEP -1 UNTIL 1 DO PADPDL[I]←PADPDL[I-1];⊃ ELSE
00800 IF PDLPTR≠0 THEN DECREM(PDLPTR);
00900 "←" IF PDLPTR≥1 THEN TOP←NVT(TOP);
01000 "`" ⊂ D0←(CASE αβ OF(0,1,2,3));DPYSUB(D0);⊃;
01100 END
01200 ELSE CASE CHR-'173 OF
01300 BEGIN
01400 "{" ;
01500 "|" IF PDLPTR≥1 ∧ ETYPE(TOP) THEN ⊂ ITG E;E←TOP;INVERT(E);
01600 AA(E)←-AA(E);BB(E)←-BB(E);CC(E)←-CC(E);⊃;
01700 "ALTMODE" CASE αβ OF ⊂ DPYSUB(2);DPYSUB(1);DPYSUB(D0);DPYSUB(3);⊃;
02000 "}" ;
02100 "RUBOUT";
02200 END;
02300 GEDREF;
02400 END "TTYCOM";
02500 END;
03100 END;
03200 GEOMED.SAI - EOF.